New Star Software Collection/NSS_Collection.iso/3-004 ms visual basic pro 30/4.imz/4.IMA/TBLSTRU.FR_/TBLSTRU.bin

Text File | 1993-04-28 | 17KB | 682 lines

VERSION 2.00
Begin Form fTblStru
   BackColor       =   &H00C0C0C0&
   Caption         =   "Table Structure"
   ClientHeight    =   5550
   ClientLeft      =   2100
   ClientTop       =   1890
   ClientWidth     =   5040
   Height          =   5955
   Left            =   2040
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   5550
   ScaleWidth      =   5040
   Top             =   1545
   Width           =   5160
   Begin TextBox cTableName
      BackColor       =   &H00FFFFFF&
      Height          =   288
      Left            =   1680
      TabIndex        =   0
      Tag             =   "OL"
      Top             =   120
      Width           =   1932
   End
   Begin PictureBox IndexBox
      BackColor       =   &H00C0C0C0&
      BorderStyle     =   0  'None
      Height          =   1692
      Left            =   0
      ScaleHeight     =   1695
      ScaleWidth      =   5055
      TabIndex        =   9
      Top             =   3720
      Width           =   5052
      Begin CommandButton PrintButton
         Caption         =   "&Print Structure"
         Height          =   372
         Left            =   720
         TabIndex        =   14
         Top             =   1320
         Visible         =   0   'False
         Width           =   1452
      End
      Begin CommandButton AddTableButton
         Caption         =   "&Build the Table"
         Enabled         =   0   'False
         Height          =   372
         Left            =   720
         TabIndex        =   8
         Top             =   1320
         Visible         =   0   'False
         Width           =   1452
      End
      Begin CommandButton CloseButton
         Cancel          =   -1  'True
         Caption         =   "&Close"
         Height          =   372
         Left            =   2880
         TabIndex        =   3
         Top             =   1320
         Width           =   1452
      End
      Begin CommandButton AddIndexButton
         Caption         =   "Add &Index"
         Height          =   252
         Left            =   1200
         TabIndex        =   5
         Top             =   120
         Width           =   1332
      End
      Begin CommandButton DelIndexButton
         Caption         =   "&Delete Index"
         Height          =   252
         Left            =   2640
         TabIndex        =   6
         Top             =   120
         Width           =   1332
      End
      Begin Grid cIndexes
         Cols            =   4
         FixedCols       =   0
         Height          =   750
         Left            =   120
         TabIndex        =   2
         Top             =   420
         Width           =   4815
      End
      Begin Line Line1
         BorderWidth     =   5
         X1              =   0
         X2              =   4800
         Y1              =   0
         Y2              =   0
      End
      Begin Label IndexesLabel
         BackColor       =   &H00C0C0C0&
         Caption         =   "Indexes:"
         Height          =   252
         Left            =   240
         TabIndex        =   10
         Top             =   120
         Width           =   1092
      End
   End
   Begin PictureBox FieldBox
      BackColor       =   &H00C0C0C0&
      BorderStyle     =   0  'None
      Height          =   2892
      Left            =   0
      ScaleHeight     =   2895
      ScaleWidth      =   5055
      TabIndex        =   11
      Top             =   600
      Width           =   5052
      Begin CommandButton RemoveFieldButton
         Caption         =   "&Remove Field"
         Height          =   252
         Left            =   2625
         TabIndex        =   7
         Top             =   0
         Width           =   1332
      End
      Begin CommandButton AddFieldButton
         Caption         =   "&Add Field"
         Height          =   252
         Left            =   1200
         TabIndex        =   4
         Top             =   0
         Width           =   1332
      End
      Begin Grid cFields
         BackColor       =   &H00FFFFFF&
         Cols            =   3
         FixedCols       =   0
         Height          =   2532
         Left            =   120
         TabIndex        =   1
         Top             =   288
         Width           =   4800
      End
      Begin Label FieldsLabel
         BackColor       =   &H00C0C0C0&
         Caption         =   "Fields:"
         Height          =   192
         Left            =   240
         TabIndex        =   12
         Top             =   0
         Width           =   732
      End
   End
   Begin Label TableNameLabel
      BackColor       =   &H00C0C0C0&
      Caption         =   "Table Name:"
      Height          =   252
      Left            =   360
      TabIndex        =   13
      Top             =   120
      Width           =   1212
   End
End

Option Explicit

Sub AddFieldButton_Click ()
  MsgBar "Enter New Field Parameters, Press 'Close' when finished", False
  fAddField.Show MODAL
  MsgBar "", False
End Sub

Sub AddIndexButton_Click ()
  MsgBar "Enter New Index Parameters, Press 'Close' when finished", False
  fIndexAdd.Show MODAL
  MsgBar "", False
End Sub

Sub AddTableButton_Click ()
  Dim tbl As New TableDef
  Dim fld As Field
  Dim ind As Index
  Dim i As Integer
  Dim x As String

  On Error GoTo ATErr

  SetHourglass Me
  MsgBar "Building New Table", True

  tbl.Name = cTableName

  'search to see if table exists
  For i = 0 To gCurrentDB.TableDefs.Count - 1
    If UCase(gCurrentDB.TableDefs(i).Name) = UCase(tbl.Name) Then
      If MsgBox(tbl.Name + " already exists, delete it?", 4) = YES Then
         gCurrentDB.TableDefs.Delete gCurrentDB.TableDefs(tbl.Name)
      Else
         ResetMouse Me
         Exit Sub
      End If
      Exit For
    End If
  Next

  'add the first field
  cFields.Row = 1
  cFields.Col = 0
  If cFields = "" Then
    Beep
    MsgBox "No Fields Defined!", 48
    Exit Sub
  End If
  Set fld = New Field
  fld.Name = cFields
  cFields.Col = 1
  fld.Type = GetFieldType((cFields))
  If cFields = "Counter" Then
    fld.Attributes = &H10   'counter type
  End If
  cFields.Col = 2
  fld.Size = Val(cFields)
  tbl.Fields.Append fld

  gCurrentDB.TableDefs.Append tbl

  'add the rest of the fields
  For i = 2 To cFields.Rows - 1
    Set fld = New Field
    cFields.Row = i
    cFields.Col = 0
    fld.Name = cFields
    cFields.Col = 1
    fld.Type = GetFieldType((cFields))
    If cFields = "Counter" Then
      fld.Attributes = &H10   'counter type
    End If
    cFields.Col = 2
    fld.Size = Val(cFields)
    gCurrentDB.TableDefs(tbl.Name).Fields.Append fld
  Next

  'add the indexes
  For i = 1 To cIndexes.Rows - 1
    Set ind = New Index
    cIndexes.Row = i
    cIndexes.Col = 0
    If cIndexes = "" Then Exit For
    ind.Name = cIndexes
    cIndexes.Col = 1
    ind.Fields = cIndexes
    cIndexes.Col = 2
    If cIndexes = "True" Then
      ind.Unique = True
    Else
      ind.Unique = False
    End If
    cIndexes.Col = 3
    If gstDataType = "ODBC" Then
      cIndexes = "N/A"
    Else
      If cIndexes = "True" Then
        ind.Primary = True
      Else
        ind.Primary = False
      End If
    End If
    gCurrentDB.TableDefs(tbl.Name).Indexes.Append ind
  Next

  RefreshTables fTables.cTableList, True

  GoTo ATEnd

ATErr:
  ResetMouse Me
  ShowError
  Resume ATEnd

ATEnd:
  ResetMouse Me
  MsgBar "", False
  Unload Me

End Sub

Sub cFields_DblClick ()
   Dim f As New fDataBox
   Dim erm As String

   'only allowed on existing tables
   If gfAddTableFlag = True Then
     Exit Sub
   End If

   On Error GoTo FldPropErr
   cFields.Row = cFields.SelStartRow
   cFields.Col = 0

   Set gCurrentField = gCurrentDB.TableDefs(fTables.cTableList).Fields(cFields)
   f.Caption = "Field Properties"
   f.Tag = "FLD"

   erm = "Name"
   f.cData.AddItem "Name = " + gCurrentField.Name
   erm = "Type"
   f.cData.AddItem "Type = " & gCurrentField.Type
   erm = "Size"
   f.cData.AddItem "Size = " & gCurrentField.Size
   erm = "SourceField"
   f.cData.AddItem "SourceField = " + gCurrentField.SourceField
   erm = "SourceTable"
   f.cData.AddItem "SourceTable = " + gCurrentField.SourceTable
   erm = "CollatingOrder"
   f.cData.AddItem "CollatingOrder = " & gCurrentField.CollatingOrder
   erm = "Attributes"
   f.cData.AddItem "Attributes = &H" & Hex(gCurrentField.Attributes)
   erm = "OrdinalPosition"
   f.cData.AddItem "OrdinalPosition = " & gCurrentField.OrdinalPosition

   f.Show MODAL

  GoTo FldPropEnd

FldPropErr:
  f.cData.AddItem erm + ":" + Error$
  Resume Next

FldPropEnd:

End Sub

Sub cIndexes_DblClick ()
   Dim f As New fDataBox
   Dim erm As String

   'only allowed on existing tables
   If gfAddTableFlag = True Then
     Exit Sub
   End If

   On Error GoTo IndPropErr
   cIndexes.Row = cIndexes.SelStartRow
   cIndexes.Col = 0

   Set gCurrentIndex = gCurrentDB.TableDefs(fTables.cTableList).Indexes(cIndexes)
   f.Caption = "Field Properties"
   f.Tag = "IND"

   erm = "Name"
   f.cData.AddItem "Name = " + gCurrentIndex.Name
   erm = "Fields"
   f.cData.AddItem "Fields = " + gCurrentIndex.Fields
   erm = "Unique"
   f.cData.AddItem "Unique Flag = " + stTrueFalse((gCurrentIndex.Unique))
   erm = "Primary"
   f.cData.AddItem "PrimaryFlag = " + stTrueFalse((gCurrentIndex.Primary))

   f.Show MODAL

  GoTo IndPropEnd

IndPropErr:
  f.cData.AddItem erm + ":" + Error$
  Resume Next

IndPropEnd:

End Sub

Sub CloseButton_Click ()
  Unload Me
  MsgBar "", False
End Sub

Sub cTableName_Change ()
  If cTableName = "" Then
    AddTableButton.Enabled = False
  Else
    AddTableButton.Enabled = True
  End If
End Sub

Sub cTableName_KeyPress (KeyAscii As Integer)
  If cTableName.TabStop = False Then
    KeyAscii = 0   'throw away the key
  End If
End Sub

Sub DelIndexButton_Click ()
  cIndexes.Row = cIndexes.SelStartRow
  cIndexes.Col = 0

  If cIndexes = "" Then Exit Sub

  If MsgBox("Delete """ + cIndexes + """ index?", MSGBOX_TYPE) = YES Then
    If gfAddTableFlag = False Then
      gCurrentDB.TableDefs(fTables.cTableList).Indexes.Delete gCurrentDB.TableDefs(fTables.cTableList).Indexes(cIndexes)
    End If
    'refresh the list of indexes
    If cIndexes.Rows = 2 Then
      cIndexes.Col = 0
      cIndexes = ""
      cIndexes.Col = 1
      cIndexes = ""
      cIndexes.Col = 2
      cIndexes = ""
    Else
      cIndexes.RemoveItem cIndexes.Row
    End If
  End If

End Sub

Sub Form_Load ()
  Dim tbl As TableDef
  Dim i As Integer
  Dim s As String
  On Error GoTo LoadErr

  Width = 5160
  Height = 5955
  SetHourglass Me
  fTables.MousePointer = HOURGLASS
  MsgBar "Opening Design Form", True
  fTblStru.cTableName.TabStop = gfAddTableFlag
  'setup field grid titles
  cFields.ColWidth(0) = 2500
  cFields.ColWidth(1) = 1500
  cFields.ColWidth(2) = 500
  cFields.Row = 0
  cFields.Col = 0
  cFields = "Name"
  cFields.Col = 1
  cFields = "Type"
  cFields.Col = 2
  cFields = "Size"
  'setup index grid titles
  cIndexes.ColWidth(0) = 850
  cIndexes.ColWidth(1) = 2250
  cIndexes.ColWidth(2) = 650
  cIndexes.ColWidth(3) = 700
  cIndexes.Row = 0
  cIndexes.Col = 0
  cIndexes = "Name"
  cIndexes.Col = 1
  cIndexes = "Indexed Fields"
  cIndexes.Col = 2
  cIndexes = "Unique"
  cIndexes.Col = 3
  cIndexes = "Primary"

  If gfAddTableFlag = True Then
    Caption = "Add Table"
    AddTableButton.Visible = True
    cFields.Rows = 2
    cIndexes.Rows = 2
  Else
    Caption = "View/Modify Structure"
    PrintButton.Visible = True
    RemoveFieldButton.Visible = False
    fTblStru.cTableName = fTables.cTableList
    Set tbl = gCurrentDB.TableDefs(fTables.cTableList)

    cFields.Rows = tbl.Fields.Count + 1
    For i = 1 To cFields.Rows - 1
      cFields.Row = i
      cFields.Col = 0
      cFields = tbl.Fields(i - 1).Name
      cFields.Col = 1
      Select Case tbl.Fields(i - 1).Type
        Case FT_TRUEFALSE
          s = "True/False"
        Case FT_BYTE
          s = "Byte"
        Case FT_INTEGER
          s = "Integer"
        Case FT_LONG
          If tbl.Fields(i - 1).Attributes And &H10 = &H10 Then
            s = "Counter"
          Else
            s = "Long"
          End If
        Case FT_CURRENCY
          s = "Currency"
        Case FT_SINGLE
          s = "Single"
        Case FT_DOUBLE
          s = "Double"
        Case FT_DATETIME
          s = "Date/Time"
        Case 9
          s = "Reserved/9"
        Case FT_STRING
          s = "String"
        Case FT_BINARY
          s = "Binary"
        Case FT_MEMO
          s = "Memo"
        Case Else
          s = CStr(tbl.Fields(i - 1).Type)
      End Select
      cFields = s
      cFields.Col = 2
      cFields = CStr(tbl.Fields(i - 1).Size)
    Next

    If tbl.Indexes.Count = 0 Then
      cIndexes.Rows = 2
    Else
      cIndexes.Rows = tbl.Indexes.Count + 1
      For i = 1 To cIndexes.Rows - 1
        cIndexes.Row = i
        cIndexes.Col = 0
        cIndexes = tbl.Indexes(i - 1).Name
        cIndexes.Col = 1
        cIndexes = tbl.Indexes(i - 1).Fields
        cIndexes.Col = 2
        If tbl.Indexes(i - 1).Unique = False Then
          s = "False"
        Else
          s = "True"
        End If
        cIndexes = s
        cIndexes.Col = 3
        If gstDataType = "ODBC" Then
          s = "N/A"
        Else
          If tbl.Indexes(i - 1).Primary = False Then
            s = "False"
          Else
            s = "True"
          End If
        End If
        cIndexes = s
      Next
    End If
  End If

  'lock the titles row and set the selected cell
  cFields.Row = 1
  cFields.SelStartCol = 0
  cFields.SelEndCol = 0
  cFields.FixedRows = 1
  cIndexes.Row = 1
  cIndexes.SelStartCol = 0
  cIndexes.SelEndCol = 0
  cIndexes.FixedRows = 1

  ResizeFieldGrid

  GoTo LoadEnd

LoadErr:
  ResetMouse Me
  fTables.MousePointer = DEFAULT_MOUSE
  ShowError
  Unload Me
  MsgBar "", False
  Exit Sub
  Resume LoadEnd

LoadEnd:
  ResetMouse Me
  fTables.MousePointer = DEFAULT_MOUSE
  MsgBar "", False

End Sub

Sub Form_Paint ()
  Outlines Me
  FieldBox.Refresh
  PicOutlines FieldBox, cFields
  IndexBox.Refresh
  PicOutlines IndexBox, cIndexes
End Sub

Sub Form_Resize ()
  On Error Resume Next

  If WindowState <> 1 Then
    If Width < 5190 Then
      Width = 5190
    End If
    FieldBox.Width = Width' - 350
    cFields.Width = FieldBox.Width - 350
    IndexBox.Width = Width' - 350
    cIndexes.Width = IndexBox.Width - 350
    Line1.X2 = IndexBox.Width
    Form_Paint
  End If
End Sub

Sub PrintButton_Click ()
  'this routine simply prints the currently
  'selected table's definition

  Dim i As Integer
  Dim s As String

  MsgBar "Printing Table Structure", True
  Printer.Print
  Printer.Print
  Printer.Print
  Printer.Print "DataBase: " + gstDBName
  Printer.Print
  Printer.Print
  Printer.Print "Table Definition for " + cTableName
  Printer.Print
  Printer.Print
  Printer.Print "Fields: (Name - Type - Size)"
  Printer.Print String(60, "-")
  For i = 1 To cFields.Rows - 1
    cFields.Row = i
    cFields.Col = 0
    s = cFields + " - "
    cFields.Col = 1
    s = s + cFields + " - "
    cFields.Col = 2
    s = s + cFields
    Printer.Print s
  Next
  Printer.Print
  Printer.Print
  Printer.Print "Index List (Name - Fields - Unique)"
  Printer.Print String(60, "-")
  For i = 1 To cIndexes.Rows - 1
    cIndexes.Row = i
    cIndexes.Col = 0
    s = cIndexes + " - "
    cIndexes.Col = 1
    s = s + cIndexes + " - "
    cIndexes.Col = 2
    s = s + cIndexes
    Printer.Print s
  Next
  Printer.NewPage
  Printer.EndDoc
  MsgBar "", False
End Sub

Sub RemoveFieldButton_Click ()
  On Error GoTo RFErr

  cFields.Row = cFields.SelStartRow
  cFields.Col = 0

  If cFields = "" Then Exit Sub

  If MsgBox("Remove """ + cFields + """ field?", MSGBOX_TYPE) = YES Then
    'refresh the list of indexes
    If cFields.Rows = 2 Then
      cFields.Col = 0
      cFields = ""
      cFields.Col = 1
      cFields = ""
      cFields.Col = 2
      cFields = ""
    Else
      cFields.RemoveItem cFields.Row
      ResizeFieldGrid
    End If
  End If
  GoTo RFEnd

RFErr:
  ShowError
  Resume RFEnd

RFEnd:

End Sub

Sub ResizeFieldGrid ()
  If cFields.Rows < 12 Then
    cFields.Height = cFields.Rows * 245
    FieldBox.Height = cFields.Height + 360
    IndexBox.Top = FieldBox.Top + FieldBox.Height + 250
    Height = IndexBox.Top + IndexBox.Height + 500
  End If
End Sub